home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 26
/
Cream of the Crop 26.iso
/
program
/
fpkpas92.zip
/
SRCRTL.ZIP
/
RTL
/
DOS
/
SYSTEM.INC
< prev
next >
Wrap
Text File
|
1997-07-01
|
51KB
|
1,908 lines
{****************************************************************************
Copyright (c) 1993,97 by
Florian Klaempfl & Michael Spiegel
****************************************************************************}
{ betriebssystemunabhaengige Implementationen der Unit System }
{$I SET.INC}
type
textbuf = array[0..127] of char;
textrec = record
handle : word;
mode : word;
bufsize : word;
{ private : word; PRIVATE is a key word }
{ lets use that field for typed file }
_private : word;
bufpos : word;
bufend : word;
bufptr : ^textbuf;
openfunc : pointer;
inoutfunc : pointer;
flushfunc : pointer;
closefunc : pointer;
userdata : array[1..16] of byte;
{$ifdef linux}
name : string[255];
{$else}
name : string[79];
{$endif}
buffer : textbuf;
end;
{ don't call this routines direct }
procedure help_constructor;
begin
asm
.globl HELP_CONSTRUCTOR_NE
HELP_CONSTRUCTOR_NE:
.globl HELP_CONSTRUCTOR
HELP_CONSTRUCTOR:
{ Einsprung ohne Prolog, da wir ESP vom Constructor brauchen }
{ Stack (relativ zu %ebp):
12 Self
8 VMT-Adresse
4 Hauptprogramm-Addr
0 %ebp
}
{ Self initialisieren? }
orl %esi,%esi
jne LHC_4
{ Speicher anfordern, aber erst Register retten }
{ Hilfsvariable }
subl $4,%esp
movl %esp,%esi
{ Register retten }
pushal
{ Speichergröße }
movl 8(%ebp),%eax
pushl (%eax)
pushl %esi
call GETMEM
popal
{ Speicherbereich nach %esi }
movl (%esi),%esi
addl $4,%esp
{ falls kein Speicher vorhanden fail() }
orl %esi,%esi
jz LHC_5
{ set zero inside the object }
pushal
pushw $0
movl 8(%ebp),%eax
pushl (%eax)
pushl %esi
{ }
call L_FILL_OBJECT
popal
{ init self for the constructor }
movl %esi,12(%ebp)
LHC_4:
{ is there a VMT address ? }
movl 8(%ebp),%eax
orl %eax,%eax
jnz LHC_7
{ falls der Konstruktor nichts macht, darf das Zero-Flag }
{ nicht gesetzt sein, da sonst fail() "aufgerufen" wird }
incl %eax
ret
LHC_7:
movl %eax,(%esi)
LHC_5:
ret
end;
end;
procedure help_fail;
begin
asm
end;
end;
procedure help_destructor;
begin
asm
{ Stack (relativ zu %ebp):
12 Self
8 VMT-Adresse
4 Hauptprogramm-Addr
0 %ebp
}
.globl HELP_DESTRUCTOR_NE
HELP_DESTRUCTOR_NE:
.globl HELP_DESTRUCTOR
HELP_DESTRUCTOR:
{ temporäre Variable }
subl $4,%esp
movl %esp,%edi
pushal
{ muß das Objekt gelöscht werden ? }
movl 8(%ebp),%eax
orl %eax,%eax
jz LHD_3
{ ja, dann Größe aus SELF! laden }
movl 12(%ebp),%eax
{ VMT-Zeiger (aus Self) nach %ebx }
movl (%eax),%ebx
{ und Größe auf den Stack }
pushl (%ebx)
{ SELF }
movl %eax,(%edi)
pushl %edi
call FREEMEM
LHD_3:
popal
addl $4,%esp
ret
end;
end;
procedure dump_stack(bp : longint);
function get_next_frame(bp : longint) : longint;
begin
asm
movl bp,%eax
movl (%eax),%eax
movl %eax,__RESULT
end ['EAX'];
end;
procedure dump_frame(addr : longint);
begin
{to be used by symify }
writeln(' 0x',HexStr(addr,8));
end;
function get_addr(BP : longint) : longint;
begin
asm
movl BP,%eax
movl 4(%eax),%eax
movl %eax,__RESULT
end ['EAX'];
end;
var i, prevbp : longint;
begin
prevbp:=bp-1;
i:=0;
while bp > prevbp do
begin
dump_frame(get_addr(bp));
i:=i+1;
if i>max_frame_dump then exit;
prevbp:=bp;
bp:=get_next_frame(bp);
end;
end;
procedure runerror(w : word);
function get_addr : longint;
begin
asm
movl (%ebp),%eax
movl 4(%eax),%eax
movl %eax,__RESULT
end;
end;
function get_error_bp : longint;
begin
asm
movl (%ebp),%eax {%ebp of run_error}
movl %eax,__RESULT
end ['EAX'];
end;
begin
errorcode:=w;
erroraddr:=pointer(get_addr);
writeln('Run time error ',errorcode,' at 0x',hexstr(longint(erroraddr),8));
dump_stack(get_error_bp);
halt(errorcode);
end;
procedure io1(addr : longint);[public,alias: 'IOCHECK'];
var
l : longint;
begin
{ da IOCHECK direkt aufgerufen wird und später der Optimierer }
{ vielleicht auch global Register zuweist }
asm
pushal
end;
l:=ioresult;
if l<>0 then
begin
writeln('I/O-Error ',l,' at ',addr);
halt(1);
end;
asm
popal
end;
end;
{$S-}
procedure st1(stack_size : longint);[public,alias: 'STACKCHECK'];
begin
{ called when trying to get local stack }
{ if the compiler directive $S is set }
asm
movl stack_size,%ebx
movl %esp,%eax
subl %ebx,%eax
{$ifdef SYSTEMDEBUG}
movl U_SYSTEM_LOWESTSTACK,%ebx
cmpl %eax,%ebx
jb _is_not_lowest
movl %eax,U_SYSTEM_LOWESTSTACK
_is_not_lowest:
{$endif SYSTEMDEBUG}
movl __stkbottom,%ebx
cmpl %eax,%ebx
jae __short_on_stack
leave
ret $4
__short_on_stack:
end['EAX','EBX'];
{ this needs a local variable }
{ so the function called itself !! }
{ Writeln('low in stack ');}
RunError(202);
end;
{no stack check in system }
procedure re_overflow;[public,alias: 'RE_OVERFLOW'];
var
addr : longint;
begin
{ write return address as overflow position }
asm
movl 4(%ebp),%edi
movl %edi,addr
end;
writeln('integer overflow at $',hexstr(addr,8));
writeln('Overflow at ',addr);
halt(1);
end;
{ kopiert Strings }
{ Darf nie direkt aufgerufen werden, da *** nicht *** mit }
{ einer Exceptionadresse auf dem Stack gerechnet wird }
{ außerdem werden Parameter von links nach rechts erwartet!! }
procedure strcopy(dstr,sstr : pointer;len : longint);[public,alias: 'STRCOPY'];
begin
asm
cld
movl 16(%ebp),%edi // Parameter laden
movl 12(%ebp),%esi
movl 8(%ebp),%ecx
lodsb // Laenge von Quelle laden
cmpb %cl,%al
jbe LM4
movb %cl,%al // wenn laenger als max. Laenge des Ziel,
// dann Quelle abschneiden
LM4:
movzbl %al,%eax
mov %eax,%ecx
stosb // Länge speichern
shrl $2,%ecx // Erst dwordweise kopieren
rep
movsl
movl %eax,%ecx // ...und nun die restlichen Bytes
andl $3,%ecx
rep
movsb
leave // eigenes Return, wegen anderem Stackframe
ret $12
end;
end;
{ verknüpft Strings }
{ Darf nie direkt aufgerufen werden, da *** nicht *** mit }
{ einer Exceptionadresse auf dem Stack gerechnet wird }
{ haengt s2 an s1 an }
{ außerdem werden Parameter von links nach rechts erwartet!! }
procedure strconcat(s1,s2 : pointer);[public,alias: 'STRCONCAT'];
begin
asm
movl 12(%ebp),%edi // Laenge des ersten Strings nach ECX
movb (%edi),%cl
movzbl %cl,%ecx
movl 12(%ebp),%edi // Startadresse fuer den zweiten String
// berechnen
lea 1(%edi,%ecx),%edi
negl %ecx // Restplatz berechnen
addl $0xff,%ecx
movl 8(%ebp),%esi // Laenge des zweiten Strings nach AL
lodsb
cmpb %cl,%al
jbe LM5
movb %cl,%al // falls zu lang, dann abschneiden
LM5:
movb %al,%cl
movl 12(%ebp),%ebx
addb %cl,(%ebx) // Resultatlaenge schreiben
movzbl %cl,%ecx
movl %ecx,%eax // Laenge retten
shrl $2,%ecx // Erst dwordweise kopieren
cld
rep
movsl
movl %eax,%ecx // ...und nun die restlichen Bytes
andl $3,%ecx
rep
movsb
leave // eigenes Return, wegen anderem Stackframe
ret $8
end ['EAX','EBX','ECX','EDI'];
end;
{ vergleicht Strings (Flags sind danach gesetzt }
{ Darf nie direkt aufgerufen werden, da *** nicht *** mit }
{ einer Exceptionadresse auf dem Stack gerechnet wird }
{ außerdem werden Parameter von links nach rechts erwartet!! }
procedure strcmp(dstr,sstr : pointer);[public,alias: 'STRCMP'];
begin
asm
movl 12(%ebp),%esi
movl 8(%ebp),%edi
cld
lodsb // Laenge des ersten Strings nach AL
movb (%edi),%ah // Laenge des zweiten Strings nach AH
incl %edi
movb %al,%cl // den kuerzeren String berechnen
cmpb %ah,%cl
jbe LSTRCONCAT1
movb %ah,%cl
LSTRCONCAT1:
orb %cl,%cl // Laenge gleich 0 ?
jz LSTRCONCAT2
movzbl %cl,%ecx
rep // Stringvergleich
cmpsb
jne LSTRCONCAT3 // Ende erreicht ?
LSTRCONCAT2:
cmpb %ah,%al // dann Laengenvergleich
LSTRCONCAT3:
leave // eigenes Return, wegen anderem Stackframe
ret $8
end;
end;
function strpas(p : pchar) : string;
begin
asm
cld
movl 12(%ebp),%edi
movl %edi,%esi // Quelle
movl $0xffffffff,%ecx // nach Ende suchen
xorb %al,%al
repne
scasb
notl %ecx
decl %ecx
movl 8(%ebp),%edi // Ziel neu laden
movb %cl,%al
stosb
rep
movsb
end ['ECX','EAX','ESI','EDI'];
end;
function strlen(p : pchar) : longint;
begin
asm
cld
movl 8(%ebp),%edi
movl $0xffffffff,%ecx
xorb %al,%al
repne
scasb
movl $0xfffffffe,%eax
subl %ecx,%eax
leave
ret $4
end ['EDI','ECX','EAX'];
end;
procedure move(var source;var dest;count : longint);
{ count : EBP+16 }
var
sp,dp : pointer;
{ sp : EBP-4 }
{ dp : EBP-8 }
begin
if count=0 then
exit;
sp:=@source;
dp:=@dest;
if sp>dp then
asm
cld
movl 16(%ebp),%ecx
movl -4(%ebp),%esi
movl -8(%ebp),%edi
movl %ecx,%eax
shrl $2,%ecx
rep
movsl
movl %eax,%ecx
andl $3,%ecx
rep
movsb
end ['ESI','EDI','ECX','EAX']
else if sp<dp then
{ vorsichtshalber rückwärts kopieren: }
asm
std
movl 16(%ebp),%ecx
movl -4(%ebp),%esi
movl -8(%ebp),%edi
addl %ecx,%esi
addl %ecx,%edi
movl %ecx,%eax
andl $3,%ecx
orl %ecx,%ecx
jz LMOVE1
{ ESI und EDI müssen erst richtig berechnet werden }
decl %esi
decl %edi
rep
movsb
incl %esi
incl %edi
LMOVE1:
subl $4,%esi
subl $4,%edi
movl %eax,%ecx
shrl $2,%ecx
rep
movsl
cld
end ['ESI','EDI','ECX'];
end;
procedure fillchar(var x;count : longint;value : byte);[alias: 'L_FILL_OBJECT'];
begin
asm
movl 8(%ebp),%edi
movl 12(%ebp),%ecx
movb 16(%ebp),%dl
// EAX mit 4fachem Byte füllen:
movb %dl,%dh
movw %dx,%ax
shll $16,%eax
movw %dx,%ax
movl %ecx,%edx
shrl $2,%ecx
cld
rep
stosl
movl %edx,%ecx
andl $3,%ecx
rep
stosb
end ['EAX','ECX','EDX','EDI'];
end;
procedure fillchar(var x;count : longint;value : char);
begin
fillchar(x,count,byte(value));
end;
procedure fillword(var x;count : longint;value : word);
begin
asm
movl 8(%ebp),%edi
movl 12(%ebp),%ecx
movw 16(%ebp),%dx
// EAX mit 4fachem Byte füllen:
movw %dx,%ax
shll $16,%eax
movw %dx,%ax
movl %ecx,%edx
shrl $1,%ecx
cld
rep
stosl
movl %edx,%ecx
andl $1,%ecx
rep
stosw
end ['EAX','ECX','EDX','EDI'];
end;
{$I INNR.INC}
function lo(w : word) : byte;[INTERNPROC: in_lo_word];
function hi(w : word) : byte;[INTERNPROC: in_hi_word];
function lo(i : integer) : byte;[INTERNPROC: in_lo_word];
function hi(i : integer) : byte;[INTERNPROC: in_hi_word];
function lo(l : longint) : word;[INTERNPROC: in_lo_long];
function hi(l : longint) : word;[INTERNPROC: in_hi_long];
function ord(c : char) : byte;[INTERNPROC: in_ord_char];
{ not fast, but easy }
function ord(b : boolean) : byte;
begin
ord:=byte(b);
end;
function chr(b : byte) : char;[INTERNPROC: in_chr_byte];
function length(s : string) : byte;[INTERNPROC: in_length_string];
procedure inc(var i : longint);[INTERNPROC: in_inc_dword];
procedure inc(var i : integer);[INTERNPROC: in_inc_word];
procedure inc(var i : word);[INTERNPROC: in_inc_word];
procedure inc(var i : shortint);[INTERNPROC: in_inc_byte];
procedure inc(var i : byte);[INTERNPROC: in_inc_byte];
procedure dec(var i : longint);[INTERNPROC: in_dec_dword];
procedure dec(var i : integer);[INTERNPROC: in_dec_word];
procedure dec(var i : word);[INTERNPROC: in_dec_word];
procedure dec(var i : shortint);[INTERNPROC: in_dec_byte];
procedure dec(var i : byte);[INTERNPROC: in_dec_byte];
procedure inc(var i : longint;a : longint);
begin
i:=i+a;
end;
procedure dec(var i : longint;a : longint);
begin
i:=i-a;
end;
procedure dec(var i : word;a : longint);
begin
i:=i-a;
end;
procedure inc(var i : word;a : longint);
begin
i:=i+a;
end;
procedure dec(var i : integer;a : longint);
begin
i:=i-a;
end;
procedure inc(var i : integer;a : longint);
begin
i:=i+a;
end;
procedure dec(var i : byte;a : longint);
begin
i:=i-a;
end;
procedure inc(var i : byte;a : longint);
begin
i:=i+a;
end;
procedure dec(var i : shortint;a : longint);
begin
i:=i-a;
end;
procedure inc(var i : shortint;a : longint);
begin
i:=i+a;
end;
function abs(l : longint) : longint;
begin
asm
movl 8(%ebp),%eax
orl %eax,%eax
jns LMABS1
negl %eax
LMABS1:
leave
ret $4
end ['EAX'];
end;
function odd(l : longint) : boolean;
begin
asm
movl 8(%ebp),%eax
andl $1,%eax
setnz %al
leave
ret $4
end ['EAX'];
end;
function sqr(l : longint) : longint;
begin
asm
movl 8(%ebp),%eax
imull %eax,%eax
leave
ret $4
end ['EAX'];
end;
{$I MATH.INC}
procedure str(l : longint;var s : string);
var
buffer : array[0..11] of byte;
begin
{ Workaround: }
if l=$80000000 then
begin
s:='-2147483648';
exit;
end;
asm
movl 8(%ebp),%eax // Integer laden
movl 12(%ebp),%edi // Stringadresse laden
xorl %ecx,%ecx // Stringlaenge=0
xorl %ebx,%ebx // Bufferlaenge=0
movl $0x0a,%esi // 10 als Konstante zum Dividieren laden
testl $0x80000000,%eax // vorzeichenbehaftet
jz LM2
neg %eax
movb $0x2d,1(%edi) // '-' in String kopieren
incl %ecx
LM2:
cdq
idivl %esi,%eax
addb $0x30,%dl // Rest in ASCII umrechnen
movb %dl,-12(%ebp,%ebx)
incl %ebx
cmpl $0,%eax
jnz LM2
// String umkopieren
LM3:
movb -13(%ebp,%ebx),%al // -13 da EBX erst spaeter
// dekremiert wird (spart Vergleich)
movb %al,1(%edi,%ecx)
incl %ecx
decl %ebx
jnz LM3
movb %cl,(%edi) // Stringlaenge kopieren
end;
end;
procedure str(i : integer;var s : string);
begin
str(longint(i),s);
end;
procedure str(si : shortint;var s : string);
begin
str(longint(si),s);
end;
procedure str(b : byte;var s : string);
begin
str(longint(b),s);
end;
procedure str(w : word;var s : string);
begin
str(longint(w),s);
end;
{ weder besonders genau noch schnell, aber solide und leicht verständlich }
procedure val(const s : string;var d : double;var code : word);
var
{ faster on a pentium }
esign,sign : double;
i : longint;
exponent : longint;
flags : byte;
hd : double;
begin
d:=0;
code:=1;
exponent:=0;
esign:=1;
flags:=0;
sign:=1;
while (s[code]=' ') or (s[code]=#9) do
inc(code);
if s[code]='+' then
inc(code)
else if s[code]='-' then
begin
sign:=-1.0;
inc(code);
end;
while (s[code]>='0') and (s[code]<='9') and (length(s)>=code) do
begin
{ Vorkomma gelesen }
flags:=flags or 1;
d:=d*10;
d:=d+(ord(s[code])-ord('0'));
inc(code);
end;
{ Kommastellen ? }
if (s[code]='.') and (length(s)>=code) then
begin
hd:=0.1;
inc(code);
{ nach einem "Komma" muß eine Ziffer folgen }
if not((s[code]>='0') and (s[code]<='9')) or (length(s)<code) then
begin
d:=0.0;
exit;
end;
while (s[code]>='0') and (s[code]<='9') and (length(s)>=code) do
begin
{ Nackkomma gelesen }
flags:=flags or 2;
d:=d+hd*(ord(s[code])-ord('0'));
hd:=hd/10.0;
inc(code);
end;
end;
{ weder Vorkomma- noch Nachkommastellen, dann abbrechen }
if flags=0 then
begin
d:=0.0;
exit;
end;
{ Exponent ? }
if (upcase(s[code])='E') and (length(s)>=code) then
begin
inc(code);
if s[code]='+' then
inc(code)
else if s[code]='-' then
begin
esign:=-1;
inc(code);
end;
if not((s[code]>='0') and (s[code]<='9')) or (length(s)<code) then
begin
d:=0.0;
exit;
end;
while (s[code]>='0') and (s[code]<='9') and (length(s)>=code) do
begin
exponent:=exponent*10;
exponent:=exponent+ord(s[code])-ord('0');
inc(code);
end;
end;
{ nun noch Exponent einrechnen }
if esign>0 then
for i:=1 to exponent do
d:=d*10
else
for i:=1 to exponent do
d:=d/10;
{ nicht alle Zeichen gelesen ? }
if length(s)>=code then
begin
d:=0.0;
exit;
end;
{ evalute sign }
d:=d*sign;
{ success ! }
code:=0;
end;
procedure val(const s : string;var b : byte);
var
l : longint;
begin
val(s,l);
b:=l;
end;
procedure val(const s : string;var b : byte;var code : word);
var
l : longint;
begin
val(s,l,code);
b:=l;
end;
procedure val(const s : string;var v : longint;var code : word);
var
i : byte;
u : byte;
negativ : boolean;
begin
negativ := false;
code := 1;
u := 0;
v := 0;
case s[1] of
'-' : begin
negativ := true;
code := 2;
end;
'+' : code := 2;
end;
case s[code] of
'$' : begin
i := 16;
inc (code);
while s[code] = #48 do inc (code);
if ord (s[0]) - code > 7 then
begin
inc (code,8);
exit;
end;
end;
'%' : begin
i := 2;
inc (code);
end
else i := 10;
end;
u := 0;
v := 0;
while chr (code) <= s[0] do
begin
case s[code] of
#48..#57 : u := ord (s[code]) - 48;
#65..#70 : u := ord (s[code]) - 55;
#97..#104 : u := ord (s[code]) - 87
else u := 16;
end;
if (2147483647 - v*i < u) and ((i = 10) or (i = 2)) then u := 16;
if u >= i then
begin
v := 0;
exit;
end;
v := (v*i + u);
inc (code);
end;
code := 0;
if negativ then v := 0-v;
end;
procedure val(const s : string;var v : longint);
var
code : word;
begin
val (s,v,code);
end;
{$I real2str.inc}
procedure str(d : double;var s : string);
begin
str_real(-1,d,s);
end;
var
randseed : longint;
function random(l : longint) : longint;
begin
randseed:=randseed*134775813+1;
random:=abs(randseed mod l);
end;
{ don't call this direct, the call is generated by the compiler }
procedure do_exit;[public,alias: '__EXIT'];
begin
while exitproc<>nil do
begin
{$ifdef DOS}
asm
movl U_SYSTEM_EXITPROC,%eax
call %eax
end;
{$endif}
{$ifdef OS2}
asm
movl U_SYSOS2_EXITPROC,%eax
call %eax
end;
{$endif}
{$ifdef LINUX}
asm
movl U_SYSLINUX_EXITPROC,%eax
call %eax
end;
{$endif}
end;
end;
{****************************************************************************
subroutines for file management
****************************************************************************}
type
filerec = record
handle : word;
mode : word;
recsize : word;
_private : array[1..26] of byte;
userdata : array[1..16] of byte;
name : string[79];
end;
{$IfNDef GO32V2}
procedure doswrite(h,addr,len : longint);forward;
function dosread(h,addr,len : longint) : longint;forward;
{$EndIf GO32V2}
procedure fileinoutfunc(var f : textrec);
begin
if f.mode=fmoutput then
begin
doswrite(f.handle,longint(f.bufptr),f.bufpos);
end
else if f.mode=fminput then
begin
f.bufend:=dosread(f.handle,longint(f.bufptr),f.bufsize);
end
else halt(100);
f.bufpos:=0;
end;
type
dateifunc = procedure(var t : textrec);
procedure fileopenfunc(var f : textrec);forward;
procedure assign(var t : text;const s : string);
begin
textrec(t).handle:=$ffff;
textrec(t).mode:=fmclosed;
textrec(t).bufsize:=128;
textrec(t).bufpos:=0;
textrec(t).bufend:=0;
textrec(t).bufptr:=@textrec(t).buffer;
textrec(t).name:=s;
textrec(t).openfunc:=@fileopenfunc;
end;
procedure assign(var f : file;const name : string);
begin
filerec(f).name:=name;
filerec(f).mode:=fmclosed;
filerec(f).handle:=$ffff;
filerec(f).recsize:=$ffff;
end;
{$ifdef typedfile }
procedure assign(var f : typedfile;const name : string);
begin
filerec(f).name:=name;
filerec(f).mode:=fmclosed;
filerec(f).handle:=$ffff;
{ here we should insert the size of the type }
{ but how can we do that }
filerec(f).recsize:=$ffff;
end;
{$endif}
procedure rewrite(var t : text);[iocheck];
begin
textrec(t).mode:=fmoutput;
dateifunc(textrec(t).openfunc)(textrec(t));
end;
procedure reset(var t : text);[iocheck];
begin
textrec(t).mode:=fminput;
dateifunc(textrec(t).openfunc)(textrec(t));
end;
procedure append(var t : text);[iocheck];
begin
textrec(t).mode:=fmappend;
dateifunc(textrec(t).openfunc)(textrec(t));
end;
procedure w(len : longint;var f : textrec;var s : string);[public,alias: 'WRITE_TEXT_STRING'];
var
hbytes,pos,copybytes : longint;
hs : string;
begin
if f.mode<>fmoutput then
exit;
copybytes:=length(s);
if len>copybytes then
begin
hs:=space(len-copybytes);
w(0,f,hs);
end;
pos:=1;
hbytes:=f.bufsize-f.bufpos;
{ wenn überhaupt kein Platz, dann ein flush durchführen }
if hbytes=0 then
dateifunc(f.flushfunc)(f);
while copybytes>hbytes do
begin
move(s[pos],f.buffer[f.bufpos],hbytes);
f.bufpos:=f.bufpos+hbytes;
dec(copybytes,hbytes);
inc(pos,hbytes);
dateifunc(f.inoutfunc)(f);
hbytes:=f.bufsize-f.bufpos;
end;
move(s[pos],f.buffer[f.bufpos],copybytes);
f.bufpos:=f.bufpos+copybytes;
end;
type
array00 = array[0..0] of char;
procedure w(len : longint;var f : textrec;const p : array00);[public,alias: 'WRITE_TEXT_PCHAR_AS_ARRAY'];
var
hbytes,pos,copybytes : longint;
hs : string;
begin
if f.mode<>fmoutput then
exit;
copybytes:=strlen(p);
if len>copybytes then
begin
hs:=space(len-copybytes);
w(0,f,hs);
end;
pos:=0;
hbytes:=f.bufsize-f.bufpos;
{ wenn überhaupt kein Platz, dann ein flush durchführen }
if hbytes=0 then
dateifunc(f.flushfunc)(f);
while copybytes>hbytes do
begin
move(p[pos],f.buffer[f.bufpos],hbytes);
f.bufpos:=f.bufpos+hbytes;
dec(copybytes,hbytes);
inc(pos,hbytes);
dateifunc(f.inoutfunc)(f);
hbytes:=f.bufsize-f.bufpos;
end;
move(p[pos],f.buffer[f.bufpos],copybytes);
f.bufpos:=f.bufpos+copybytes;
end;
procedure wa(len : longint;var f : textrec;p : pchar);[public,alias: 'WRITE_TEXT_PCHAR_AS_POINTER'];
begin
w(len,f,p);
end;
procedure f1;[public,alias: 'FLUSH_STDOUT'];
begin
asm
pushal
end;
dateifunc(textrec(output).flushfunc)(textrec(output));
asm
popal
end;
end;
procedure flush(var t : text);[iocheck];
begin
if textrec(t).mode<>fmoutput then
exit;
dateifunc(textrec(t).flushfunc)(textrec(t));
end;
procedure doserase(p : pchar);forward;
procedure dosrename(p1,p2 : pchar);forward;
procedure erase(var t : text);[iocheck];
var
b : array[0..79] of char;
begin
if textrec(t).mode=fmclosed then
begin
move(textrec(t).name[1],b,length(textrec(t).name));
b[length(textrec(t).name)]:=#0;
doserase(b);
end;
end;
procedure erase(var f : file);[iocheck];
var
b : array[0..79] of char;
begin
if filerec(f).mode=fmclosed then
begin
move(filerec(f).name[1],b,length(filerec(f).name));
b[length(filerec(f).name)]:=#0;
doserase(b);
end;
end;
procedure rename(var f : file;const s : string);[iocheck];
var
b1,b2 : array[0..79] of char;
begin
if filerec(f).mode=fmclosed then
begin
move(filerec(f).name[1],b1,length(filerec(f).name));
b1[length(filerec(f).name)]:=#0;
move(s[1],b2,length(s));
b2[length(s)]:=#0;
dosrename(b1,b2);
filerec(f).name:=s;
end;
end;
procedure rename(var t : text;const s : string);[iocheck];
var
b1,b2 : array[0..79] of char;
begin
if textrec(t).mode=fmclosed then
begin
move(textrec(t).name[1],b1,length(textrec(t).name));
b1[length(textrec(t).name)]:=#0;
move(s[1],b2,length(s));
b2[length(s)]:=#0;
dosrename(b1,b2);
textrec(t).name:=s;
end;
end;
procedure w(len : longint;var t : textrec;l : longint);[public,alias: 'WRITE_TEXT_LONGINT'];
var
s : string;
begin
str(l,s);
w(len,t,s);
end;
procedure w(fixkomma,len : longint;var t : textrec;r : real);[public,alias: 'WRITE_TEXT_REAL'];
var
s : string;
begin
str_real(fixkomma,r,s);
w(len,t,s);
end;
{ heißt wc, damit der Compiler keinen rekursiven Aufruf erzeugt }
procedure wc(len : longint;var t : textrec;c : char);[public,alias: 'WRITE_TEXT_CHAR'];
var
hs : string;
begin
if t.mode<>fmoutput then
exit;
if len>1 then
begin
hs:=space(len-1);
w(0,t,hs);
end;
if t.bufpos+1>=t.bufsize then
dateifunc(t.flushfunc)(t);
t.buffer[t.bufpos]:=c;
inc(t.bufpos);
end;
procedure r(var f : textrec);[public,alias: 'READLN_TEXT'];
begin
{ file must be opened for reading }
if f.mode<>fminput then
exit;
{ Noch Zeichen im Buffer? ansonsten laden }
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
while f.buffer[f.bufpos]<>#10 do
begin
{ trotz Laden nichts im Buffer ? }
if f.bufpos>=f.bufend then
{ dann vergiss' s }
exit;
inc(f.bufpos);
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
end;
inc(f.bufpos);
end;
procedure r(var f : textrec;var s : string);[public,alias: 'READ_TEXT_STRING'];
begin
{ the file must be opened for input }
if f.mode<>fminput then
exit;
{ delete the string }
s:='';
{ Noch Zeichen im Buffer? ansonsten Laden }
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
while f.buffer[f.bufpos]<>#10 do
begin
{ if no chars in the buffer, then forget this }
if f.bufpos>=f.bufend then
exit;
if f.buffer[f.bufpos]<>#13 then
s:=s+f.buffer[f.bufpos];
inc(f.bufpos);
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
end;
end;
procedure r(var f : textrec;var l : longint);[public,alias: 'READ_TEXT_LONGINT'];
var
hs : string;
code : word;
label
ready;
begin
if f.mode<>fminput then
exit;
{ del the number }
l:=0;
{ clear the string }
hs:='';
{ Noch Zeichen im Buffer? ansonsten Laden }
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
{ ignore spaces }
while (f.buffer[f.bufpos]=#13) or
(f.buffer[f.bufpos]=#10) or
(f.buffer[f.bufpos]=#9) or
(f.buffer[f.bufpos]=' ') do
begin
{ if no chars in the buffer, then forget this }
if f.bufpos>=f.bufend then
exit;
inc(f.bufpos);
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
end;
{ read the sign }
if (f.buffer[f.bufpos]='-') or
(f.buffer[f.bufpos]='+') then
begin
{ if no chars in the buffer, then forget this }
if f.bufpos>=f.bufend then
goto ready;
hs:=hs+f.buffer[f.bufpos];
inc(f.bufpos);
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
end;
while (ord(f.buffer[f.bufpos])>=ord('0')) and
(ord(f.buffer[f.bufpos])<=ord('9')) do
begin
{ if no chars in the buffer, then forget this }
if f.bufpos>=f.bufend then
goto ready;
hs:=hs+f.buffer[f.bufpos];
inc(f.bufpos);
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
end;
ready:
val(hs,l,code);
if code<>0 then
runerror(106);
end;
procedure r(var f : textrec;var l : integer);[public,alias:'READ_TEXT_INTEGER'];
var
v : longint;
begin
r(f,v);
l:=v;
end;
procedure r(var f : textrec;var l : word);[public,alias:'READ_TEXT_WORD'];
var
v : longint;
begin
r(f,v);
l:=v;
end;
procedure r(var f : textrec;var l : shortint);[public,alias:'READ_TEXT_SHORTINT'];
var
v : longint;
begin
r(f,v);
l:=v;
end;
procedure r(var f : textrec;var l : byte);[public,alias:'READ_TEXT_BYTE'];
var
v : longint;
begin
r(f,v);
l:=v;
end;
procedure r(var f : textrec;var c : char);[public,alias: 'READ_TEXT_CHAR'];
var
hs : string;
code : word;
begin
c:=#0;
{ the file must be opened for input }
if f.mode<>fminput then
exit;
{ maybe reload }
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
if f.bufpos>=f.bufend then
c:=#26
else c:=f.buffer[f.bufpos];
inc(f.bufpos);
end;
procedure r(var f : textrec;var d : double);[public,alias: 'READ_TEXT_REAL'];
var
hs : string;
code : word;
label
ready;
begin
{ f... long code }
if f.mode<>fminput then
exit;
{ del the number }
d:=0.0;
{ clear the string }
hs:='';
{ maybe reload }
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
{ ignore spaces }
while (f.buffer[f.bufpos]=#13) or
(f.buffer[f.bufpos]=#10) or
(f.buffer[f.bufpos]=#9) or
(f.buffer[f.bufpos]=' ') do
begin
{ if no chars in the buffer, then forget this }
if f.bufpos>=f.bufend then
exit;
inc(f.bufpos);
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
end;
{ read the sign }
if (f.buffer[f.bufpos]='-') or
(f.buffer[f.bufpos]='+') then
begin
{ if no chars in the buffer, then forget this }
if f.bufpos>=f.bufend then
goto ready;
hs:=hs+f.buffer[f.bufpos];
inc(f.bufpos);
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
end;
while (ord(f.buffer[f.bufpos])>=ord('0')) and
(ord(f.buffer[f.bufpos])<=ord('9')) do
begin
{ if no chars in the buffer, then forget this }
if f.bufpos>=f.bufend then
goto ready;
hs:=hs+f.buffer[f.bufpos];
inc(f.bufpos);
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
end;
{ comma ? }
if (f.buffer[f.bufpos]='.') then
begin
{ if no chars in the buffer, then forget this }
if f.bufpos>=f.bufend then
goto ready;
hs:=hs+'.';
inc(f.bufpos);
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
while (ord(f.buffer[f.bufpos])>=ord('0')) and
(ord(f.buffer[f.bufpos])<=ord('9')) do
begin
{ if no chars in the buffer, then forget this }
if f.bufpos>=f.bufend then
goto ready;
hs:=hs+f.buffer[f.bufpos];
inc(f.bufpos);
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
end;
end;
{ exponent ? }
if (upcase(f.buffer[f.bufpos])='E') then
begin
{ if no chars in the buffer, then forget this }
if f.bufpos>=f.bufend then
goto ready;
hs:=hs+'E';
inc(f.bufpos);
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
{ read the sign of the exponent }
if (f.buffer[f.bufpos]='-') or
(f.buffer[f.bufpos]='+') then
begin
{ if no chars in the buffer, then forget this }
if f.bufpos>=f.bufend then
goto ready;
hs:=hs+f.buffer[f.bufpos];
inc(f.bufpos);
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
end;
while (ord(f.buffer[f.bufpos])>=ord('0')) and
(ord(f.buffer[f.bufpos])<=ord('9')) do
begin
{ if no chars in the buffer, then forget this }
if f.bufpos>=f.bufend then
goto ready;
hs:=hs+f.buffer[f.bufpos];
inc(f.bufpos);
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
end;
end;
ready:
val(hs,d,code);
if code<>0 then
runerror(106);
end;
{$ifndef VER0_6}
procedure r(var f : textrec;var s : pchar);[public,alias:'READ_TEXT_PCHAR_AS_POINTER'];
var p : pchar;
begin
{ the file must be opened for input }
if (f.mode<>fminput) or (s=nil) then
exit;
{ delete the string }
s^:=#0;
p:=s;
{ if there are no more chars in the buffer then reload }
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
while f.buffer[f.bufpos]<>#10 do
begin
{ if no chars in the buffer, then forget this }
if f.bufpos>=f.bufend then
exit;
if f.buffer[f.bufpos]<>#13 then
move (f.buffer[f.bufpos],p^,1);
inc (longint(p));
p^:=#0;
inc(f.bufpos);
if f.bufpos>=f.bufend then
dateifunc(f.inoutfunc)(f);
end;
end;
procedure r(var f : textrec;var fi : fixed);[public,alias: 'READ_TEXT_FIXED'];
var
d : double;
begin
r(f,d);
{ longint(fi):=trunc(65536*d); }
end;
{$endif VER0_6}
function ioresult : word;
begin
ioresult:=inoutres;
inoutres:=0;
end;
procedure blockread(var f : file;var buf;count : word;var result : word);[iocheck];
var
rl : longint;
begin
blockread(f,buf,count,rl);
result:=rl;
end;
procedure w(var t : textrec);[public,alias: 'WRITELN_TEXT'];
var
hs : string;
begin
hs:=#13#10;
w(0,t,hs);
end;
procedure close(var t : text);[public,alias: 'CLOSE_TEXT',iocheck];
begin
if (textrec(t).mode<>fmclosed) then
begin
dateifunc(textrec(t).flushfunc)(textrec(t));
textrec(t).mode:=fmclosed;
dateifunc(textrec(t).closefunc)(textrec(t));
end;
end;
procedure initexception;[public,alias: 'INITEXCEPTION'];
begin
writeln('Exception während der Programminitialisierung aufgetreten');
halt;
end;
function ptr(sel,off : word) : pointer;
begin
{$ifdef DOS}
ptr:=pointer($e0000000+sel shl 4+off);
{$else}
ptr:=pointer(sel shl 4+off);
{$endif}
end;
function eof : boolean;
begin
eof:=eof(input);
end;
function eoln(var t : text) : boolean;
begin
{ maybe we need new data }
if textrec(t).bufpos>=textrec(t).bufend then
dateifunc(textrec(t).inoutfunc)(textrec(t));
eoln:=eof or
(textrec(t).buffer[textrec(t).bufpos]=#13) or
(textrec(t).buffer[textrec(t).bufpos]=#10);
end;
function eoln : boolean;
begin
eoln:=eoln(input);
end;
{****************************************************************************
subroutines for string handling
****************************************************************************}
function copy(const s : string;index : integer;count : byte): string;
var
i : longint;
begin
if count < 0 then count := 0;
if index <= 0 then index := 1;
if index <= ord(s[0]) then
begin
if count + index > ord(s[0]) then copy[0] := chr (ord(s[0]) - index +1)
else copy[0] := chr (count);
for i := 1 to ord (s[0]) do copy[i] := s [index -1 + i];
end
else copy[0] := #0;
end;
procedure delete(var s : string;index : integer;count : integer);
var i : longint;
begin
if index <= 0 then
begin
count := count + index -1;
index := 1;
end;
if count <= 0 then exit;
if ord (s[0]) >= index then
begin
if count + index > ord (s[0]) then count:= ord (s[0]) -index + 1;
for i := 0 to ord (s[0]) - (count+index) do
s [i+index] := s[i+count+index];
s[0] := chr(ord (s[0]) - count);
end;
end;
procedure insert(const source : string;var s : string;index : integer);
var s3 : string;
begin
if index <= 0 then index := 1;
s3 := copy (s, index, length(s));
if index > length (s) then index := ord(s[0]) +1;
s[0] := chr (index - 1);
s := s + source + s3;
end;
function pos(const substr : string;const s : string): byte;
var i : longint;
j : byte;
e : boolean;
begin
i := 0;
j := 0;
e := true;
if substr = '' then e := false;
while (e) and (i <= length (s) - length (substr)) do
begin
inc (i);
if substr = copy (s,i,length (substr)) then
begin
j := i;
e := false;
end;
end;
pos := j;
end;
function upcase(c : char) : char;
begin
if (c >= #97) and (c <= #122) then c := chr(ord (c) - 32)
else if (c >= #128) and (c <= #165) then
case c of
#129 : c := #154; {D}
#132 : c := #142; {D}
#148 : c := #153; {D}
#130 : c := #144; {F}
#135 : c := #128; {F}
#134 : c := #143; {E}
#164 : c := #165; {E}
end;
upcase := c;
end;
function upcase(const s : string) : string;
var i : longint;
begin
upcase[0]:=s[0];
for i := 1 to length (s) do
upcase[i] := upcase (s[i]);
end;
function lowercase(c : char) : char;
begin
if (c >= #65) and (c <= #90) then c := chr(ord (c) + 32)
else if (c >= #128) and (c <= #165) then
case c of
#154 : c := #129; {D}
#142 : c := #132; {D}
#153 : c := #148; {D}
#144 : c := #130; {F}
#128 : c := #135; {F}
#143 : c := #134; {E}
#165 : c := #164; {E}
end;
lowercase := c;
end;
function lowercase(const s : string) : string;
var i : longint;
begin
lowercase [0] := s[0];
for i := 1 to length (s) do
lowercase[i] := lowercase (s[i]);
end;
function space (b : byte): string;
var i : longint;
begin
space[0] := chr(b);
for i := 1 to b do space[i] := #32;
end;
function hexstr(val : longint;cnt : byte) : string;
const
hexval : string[16]=('0123456789ABCDEF');
var
s : string;
l2,i : integer;
l1 : longInt;
begin
s[0]:=char(cnt);
l1:=longint($f) shl (4*(cnt-1));
for i:=1 to cnt do
begin
l2:=(val and l1) shr (4*(cnt-i));
l1:=l1 shr 4;
s[i]:=hexval[l2+1];
end;
hexstr:=s;
end;
function binstr(val : longint;cnt : byte) : string;
var
s : string;
mask,i : word;
begin
s[0]:=char(cnt);
mask:=word(1) shl (cnt-1);
for i:=1 to cnt do
begin
if (val and mask)<>0 then
s[i]:='1' else s[i]:='0';
mask:=mask shr 1;
end;
binstr:=s;
end;
{ old version doesn't like this }
{$ifdef dummy}
{$ifndef VER0_6_5}
{$ifndef VER0_6_4}
constructor tobject.create;
begin
end;
destructor tobject.free;
begin
end;
{$endif}
{$endif}
{$endif}